﻿'Copyright (c) 2009 Grailtek

'Permission is hereby granted, free of charge, to any person
'obtaining a copy of this software and associated documentation
'files (the "Software"), to deal in the Software without
'restriction, including without limitation the rights to use,
'copy, modify, merge, publish, distribute, sublicense, and/or sell
'copies of the Software, and to permit persons to whom the
'Software is furnished to do so, subject to the following
'conditions:

'The above copyright notice and this permission notice shall be
'included in all copies or substantial portions of the Software.

'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
'EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
'OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
'NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
'HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
'WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
'FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
'OTHER DEALINGS IN THE SOFTWARE.

Imports System.Reflection
Imports System.Reflection.Emit
Imports System.Aspect

<DebuggerStepThrough()> _
Public Module ExecutorServices

#Region "public fields / methods"

    Public Function GetNew(Of T As Class)() As T
        Return ImplementorFactory.GetNewOf(Of T)()
    End Function

    Public Function GetImplementingType(ByVal interfaceType As Type) As Type
        Return ImplementorFactory.GetImplementingType(interfaceType)
    End Function

    Public DispatchSorter As IComparer(Of IAspectAction)
    Public ReadOnly DispatchListeners As New List(Of IDispatchListener)

    Public Sub AddDefaultTrace()
        If Not DispatchListeners.Contains(DispatchTraceEmitter.Default) Then DispatchListeners.Add(DispatchTraceEmitter.Default)
    End Sub

    Public Function GetAspectSet(Of AspectType As {Attribute, IAspect})(ByVal Assy As Assembly) As AspectType()
        Dim ret As New List(Of AspectType)
        For Each t As Type In Assy.GetTypes
            For Each aspT As AspectType In t.GetCustomAttributes(False).OfType(Of AspectType)()
                aspT.DelegateInfo = ExecutorServices.GetDelegateInfo(t)
                ret.Add(aspT)
            Next
        Next
        Return ret.ToArray
    End Function

    Public Function GetVerbs(ByVal assy As Assembly, ByVal PublicOnly As Boolean) As Verb()
        Static VerbsLookup As New Dictionary(Of Assembly, Verb())
        Dim ret(-1) As Verb
        If Not VerbsLookup.TryGetValue(assy, ret) Then
            Dim list As New List(Of Verb)
            For Each t As Type In assy.GetTypes
                For Each v As IVerb In t.GetCustomAttributes(False).OfType(Of IVerb)()
                    If Not PublicOnly OrElse t.IsPublic OrElse t.IsNestedPublic Then
                        list.Add(New Verb(v, GetDelegateInfo(t)))
                    End If
                Next
            Next
            ret = list.ToArray
            VerbsLookup.Add(assy, ret)
        End If
        Return ret
    End Function

    Public Function GetItems(ByVal assy As Assembly, ByVal PublicOnly As Boolean) As Item()
        Static ObjectsLookup As New Dictionary(Of Assembly, Item())
        Dim ret(-1) As Item
        If Not ObjectsLookup.TryGetValue(assy, ret) Then
            Dim list As New List(Of Item)
            For Each t As Type In assy.GetTypes
                For Each i As ItemAttribute In t.GetCustomAttributes(False).OfType(Of ItemAttribute)()
                    If Not PublicOnly OrElse t.IsPublic OrElse t.IsNestedPublic Then
                        list.Add(New Item(i, t))
                    End If
                Next
            Next
            ret = list.ToArray
            ObjectsLookup.Add(assy, ret)
        End If
        Return ret
    End Function

    'TODO: memoization (direct, not with dictionary)
    Public Function GetAspect(ByVal DelegateType As Type) As Object
        Debug.Assert(Not Methods.AspectMethod Is Nothing)
        Dim m As MethodInfo = Methods.AspectMethod.MakeGenericMethod(New Type() {DelegateType})
        Return m.Invoke(Nothing, Nothing)
    End Function

    Public Function Aspect(Of TDelegate As Class)() As TDelegate
        Return Aspect(Of TDelegate)(Nothing)
    End Function

    Private Structure TypeValidatorPair
        Public DelegateType As Type
        Public Validator As Object
    End Structure

    Private ReadOnly _CreatedMethods As New Dictionary(Of TypeValidatorPair, System.Delegate)

    Public ReadOnly Property CreatedMethods() As IEnumerable(Of [Delegate])
        Get
            Return _CreatedMethods.Values
        End Get
    End Property

    'TODO: this method's signature needs one more parameter
    Public Function Aspect(Of TDelegate As Class)(ByVal Validator As TDelegate) As TDelegate

        Dim ret As TDelegate = Nothing

        Debug.Assert(Not Methods.Execute Is Nothing)
        Debug.Assert(Not Methods.FailFunction Is Nothing)
        Debug.Assert(Not Methods.FailSub Is Nothing)
        Debug.Assert(Not Methods.GetDelegateInfoMethod Is Nothing)
        Debug.Assert(Not Methods.GetItem Is Nothing)
        Debug.Assert(Not Methods.GetItems Is Nothing)
        Debug.Assert(Not Methods.GetTypeFromHandle Is Nothing)
        Debug.Assert(Not Methods.GetValue Is Nothing)
        Debug.Assert(Not Methods.GetValues Is Nothing)

        Try

            Dim delegateType As Type = GetType(TDelegate)
            If Not GetType(MulticastDelegate).IsAssignableFrom(delegateType) Then Return Nothing

            Dim tvp As New TypeValidatorPair With {.DelegateType = delegateType, .Validator = Validator}
            Dim del As System.Delegate = Nothing

            'NOTE: this is not a function that needs to have a high performance for repeat calls,
            ' the lookup is more to prevent duplicates from being created for dynamic invocations
            If _CreatedMethods.TryGetValue(tvp, del) Then

                ret = DirectCast(DirectCast(del, Object), TDelegate)

            Else

                Debug.WriteLine(String.Format("Creating method for delegate type {0}", GetType(TDelegate).FullName))

                Dim invoke As MethodInfo = delegateType.GetMethod("Invoke")
                Dim paramTypes() As Type = invoke.GetParameters.Select(Of Type)(Function(p As ParameterInfo) p.ParameterType).ToArray
                Dim dyn As New DynamicMethod("ExecutorServices_dyn__" & delegateType.FullName, invoke.ReturnType, paramTypes, True)
                Dim il As ILGenerator = dyn.GetILGenerator

                If Not Validator Is Nothing Then
                    For i As Integer = 0 To paramTypes.GetUpperBound(0)
                        il.Emit(OpCodes.Ldarg, i)
                    Next
                    Dim validatorDelegate As [Delegate] = DirectCast(DirectCast(Validator, Object), [Delegate])
                    il.Emit(OpCodes.Call, validatorDelegate.Method)
                    If Not validatorDelegate.Method.ReturnType Is GetType(System.Void) Then
                        il.Emit(OpCodes.Pop) 'discard result, validator only returns a value because it must have the same sig as its delegate
                    End If
                End If

                il.Emit(OpCodes.Call, Methods.GetDelegateInfoMethod.MakeGenericMethod(New Type() {delegateType}))

                Dim locArgs As LocalBuilder = il.DeclareLocal(GetType(Object()))
                il.Emit(OpCodes.Ldc_I4, dyn.GetParameters.Count)
                il.Emit(OpCodes.Newarr, GetType(Object))

                For i As Integer = 0 To paramTypes.GetUpperBound(0)
                    il.Emit(OpCodes.Stloc, locArgs.LocalIndex)
                    il.Emit(OpCodes.Ldloc, locArgs.LocalIndex)
                    il.Emit(OpCodes.Ldc_I4, i)
                    il.Emit(OpCodes.Ldarg, i)
                    il.Emit(OpCodes.Box, paramTypes(i))
                    il.Emit(OpCodes.Stelem, GetType(Object))
                    il.Emit(OpCodes.Ldloc, locArgs.LocalIndex)
                Next

                Dim returnsArray As Boolean = dyn.ReturnType.IsArray
                Dim returnType As Type = If(returnsArray, dyn.ReturnType.GetElementType, dyn.ReturnType)
                Dim m As MethodInfo
                If returnType Is GetType(System.Void) Then
                    m = Methods.Execute
                Else
                    If GetType(IConvertible).IsAssignableFrom(returnType) Then
                        If returnsArray Then
                            m = Methods.GetValues.MakeGenericMethod(New Type() {returnType})
                        Else
                            m = Methods.GetValue.MakeGenericMethod(New Type() {returnType})
                        End If
                    Else
                        If returnType.IsInterface Then returnType = ImplementorFactory.GetImplementingType(returnType)
                        If HasPublicParameterlessConstructor(returnType) Then
                            If returnsArray Then
                                m = Methods.GetItems.MakeGenericMethod(New Type() {returnType})
                            Else
                                m = Methods.GetItem.MakeGenericMethod(New Type() {returnType})
                            End If
                        Else
                            'return type is not trivailly constructable, is not an interface, and we haven't implemented a ResultProvider attribute for the output field
                            Debug.Fail(String.Format("Return type {0} is not constructable, function will always return null.", returnType.Name))
                            m = Methods.Execute
                        End If
                    End If
                End If

                'il.Emit(OpCodes.Pop) 'for testing, uncommenting this will cause an InvalidProgramException
                il.Emit(OpCodes.Call, m)
                il.Emit(OpCodes.Ret)

                Dim o As Object = DirectCast(dyn.CreateDelegate(delegateType), Object)

                ret = DirectCast(o, TDelegate)

                _CreatedMethods.Add(tvp, DirectCast(o, [Delegate]))

                Debug.WriteLine(String.Format("Created method {0}", dyn.Name))

            End If

            'TODO: need to find a way to do type safety validation
            ' it should never happen, but I'd still like to be able to test for and catch a type saftey failure here just in case it is possible (peverify?)
        Catch iex As InvalidProgramException

            Debug.Fail("failed to render dynamic method: " & iex.Message)
            ret = Nothing

        End Try

        'NOTE: Even though it should never happen, we do everything possible here to never fail to return a working method.
        ' By returning a special failure delegate, we can give the developer a far more useful exception than an otherwise
        ' inevitable NullReferenceException, or worse, a completely useless TypeLoadException
        If ret Is Nothing Then ret = GetMethodFailedDelegate(Of TDelegate)()

        Return ret

    End Function

#End Region

#Region "support"

    Private Function GetMethodFailedDelegate(Of TDelegate As Class)() As TDelegate
        Dim ret As TDelegate = Nothing
        Try
            Dim delegateType As Type = GetType(TDelegate)
            Dim invoke As MethodInfo = delegateType.GetMethod("Invoke")
            Dim paramTypes() As Type = invoke.GetParameters.Select(Of Type)(Function(p As ParameterInfo) p.ParameterType).ToArray
            Dim dyn As New DynamicMethod("ExecutorServices_dyn__FAIL__" & delegateType.FullName, invoke.ReturnType, paramTypes, True)
            Dim il As ILGenerator = dyn.GetILGenerator
            Dim m As MethodInfo
            If dyn.ReturnType Is GetType(System.Void) Then
                m = Methods.FailSub.MakeGenericMethod(New Type() {delegateType})
            Else
                m = Methods.FailFunction.MakeGenericMethod(New Type() {delegateType, dyn.ReturnType})
            End If
            il.Emit(OpCodes.Call, m)
            il.Emit(OpCodes.Ret)
            ret = DirectCast(DirectCast(dyn.CreateDelegate(delegateType), Object), TDelegate)
        Catch iex As InvalidProgramException
            Debug.Fail("failed to render default dynamic method: " & iex.Message) 'uh oh, we just failed at failing
            ret = Nothing
        End Try
        Return ret
    End Function

    Private Function FailFunction(Of T, TReturn)() As TReturn
        FailSub(Of T)()
    End Function

    Private Sub FailSub(Of T)()
        Throw New InvalidProgramException(String.Format("failed to render dynamic method for delegate type {0}", GetType(T).FullName))
    End Sub

    Private NotInheritable Class Methods
        Private Sub New()
        End Sub
        Private Const bPrv As BindingFlags = BindingFlags.Static Or BindingFlags.NonPublic
        Private Const bPub As BindingFlags = BindingFlags.Static Or BindingFlags.Public
        Private Shared ReadOnly t As Type = GetType(ExecutorServices)
        Public Shared ReadOnly GetTypeFromHandle As MethodInfo = GetType(Type).GetMethod("GetTypeFromHandle", BindingFlags.Static Or BindingFlags.Public, Nothing, New Type() {GetType(RuntimeTypeHandle)}, Nothing)
        Public Shared ReadOnly Execute As MethodInfo = t.GetMethod("Execute", bPrv)
        Public Shared ReadOnly GetItem As MethodInfo = t.GetMethod("GetItem", bPrv)
        Public Shared ReadOnly GetItems As MethodInfo = t.GetMethod("GetItems", bPrv)
        Public Shared ReadOnly GetValue As MethodInfo = t.GetMethod("GetValue", bPrv)
        Public Shared ReadOnly GetValues As MethodInfo = t.GetMethod("GetValues", bPrv)
        Public Shared ReadOnly FailSub As MethodInfo = t.GetMethod("FailSub", bPrv)
        Public Shared ReadOnly FailFunction As MethodInfo = t.GetMethod("FailFunction", bPrv)
        Public Shared ReadOnly GetDelegateInfoMethod As MethodInfo = t.GetMethod("GetDelegateInfo", bPrv, Nothing, Nothing, Type.EmptyTypes, Nothing)
        Public Shared ReadOnly AspectMethod As MethodInfo = t.GetMethod("Aspect", bPub, Nothing, Nothing, Type.EmptyTypes, Nothing)
    End Class

    <DebuggerStepThrough()> _
    Private Class DelegateInfoHolder(Of TDelegate)
        Public Shared Info As DelegateInfo = New DelegateInfo(GetType(TDelegate))
    End Class

    Private Function GetDelegateInfo(Of TDelegate)() As DelegateInfo
        Return DelegateInfoHolder(Of TDelegate).Info
    End Function

    Private Function GetDelegateInfo(ByVal delegateType As Type) As DelegateInfo
        Dim ret As DelegateInfo = Nothing
        Dim m As MethodInfo = Methods.GetDelegateInfoMethod.MakeGenericMethod(New Type() {delegateType})
        Dim o As Object = m.Invoke(Nothing, BindingFlags.Static Or BindingFlags.NonPublic, Nothing, Nothing, Nothing)
        If Not o Is Nothing Then ret = DirectCast(o, DelegateInfo)
        Return ret
    End Function

#End Region

#Region "dispatch"

    Public Interface IDispatchListener
        Sub BeforeDispatch(ByVal Aspect As IAspect, ByVal delegateInfo As DelegateInfo, ByVal args As Argument())
        Sub AfterDispatch(ByVal Aspect As IAspect, ByVal delegateInfo As DelegateInfo, ByVal args As Argument(), ByVal returnedObject As Object)
    End Interface

    Private Sub OnBeforeDispatch(ByVal Aspect As IAspect, ByVal delegateInfo As DelegateInfo, ByVal args As Argument())
        For Each d As IDispatchListener In DispatchListeners
            d.BeforeDispatch(Aspect, delegateInfo, args)
        Next
        For Each a As IAspect In delegateInfo.Aspects
            a.BeforeInvoke(args)
        Next
    End Sub

    Private Sub OnAfterDispatch(ByVal Aspect As IAspect, ByVal delegateInfo As DelegateInfo, ByVal args() As Argument, ByVal returnedObject As Object)
        For Each d As IDispatchListener In DispatchListeners
            d.AfterDispatch(Aspect, delegateInfo, args, returnedObject)
        Next
    End Sub

    Private Sub Execute(ByVal DelegateInfo As DelegateInfo, ByVal callArgs() As Object)
        If Not DispatchSorter Is Nothing Then System.Array.Sort(DelegateInfo.Actions, DispatchSorter)
        Dim args As Argument() = DelegateInfo.GetArgs(callArgs)
        For Each item As IAspectAction In DelegateInfo.Actions
            OnBeforeDispatch(item, DelegateInfo, args)
            item.Execute(args)
            OnAfterDispatch(item, DelegateInfo, args, Nothing)
        Next
    End Sub

    'TODO: it is best to always call every retriever, or just the first? should this be a configurable strategy?
    Private Function GetItem(Of T As New)(ByVal DelegateInfo As DelegateInfo, ByVal callArgs() As Object) As T
        If Not DispatchSorter Is Nothing Then System.Array.Sort(DelegateInfo.Actions, DispatchSorter)
        Dim args As Argument() = DelegateInfo.GetArgs(callArgs)
        Dim ret As T = Nothing
        For Each item As IAspectFunction In DelegateInfo.Functions
            OnBeforeDispatch(item, DelegateInfo, args)
            ret = item.GetItem(Of T)(DelegateInfo.OutputMappings, args)
            OnAfterDispatch(item, DelegateInfo, args, ret)
        Next
        Return ret
    End Function

    Private Function GetItems(Of T As New)(ByVal DelegateInfo As DelegateInfo, ByVal callArgs() As Object) As T()
        If Not DispatchSorter Is Nothing Then System.Array.Sort(DelegateInfo.Actions, DispatchSorter)
        Dim args As Argument() = DelegateInfo.GetArgs(callArgs)
        Dim ret As T() = New T() {}
        For Each item As IAspectFunction In DelegateInfo.Functions
            OnBeforeDispatch(item, DelegateInfo, args)
            ret = item.GetItems(Of T)(DelegateInfo.OutputMappings, args)
            OnAfterDispatch(item, DelegateInfo, args, ret)
        Next
        Return ret
    End Function

    Private Function GetValue(Of T As IConvertible)(ByVal DelegateInfo As DelegateInfo, ByVal callArgs() As Object) As T
        If Not DispatchSorter Is Nothing Then System.Array.Sort(DelegateInfo.Actions, DispatchSorter)
        Dim args As Argument() = DelegateInfo.GetArgs(callArgs)
        Dim ret As T = Nothing
        For Each item As IAspectFunction In DelegateInfo.Functions
            OnBeforeDispatch(item, DelegateInfo, args)
            ret = item.GetValue(Of T)(args)
            OnAfterDispatch(item, DelegateInfo, args, ret)
        Next
        Return ret
    End Function

    Private Function GetValues(Of T As IConvertible)(ByVal DelegateInfo As DelegateInfo, ByVal callArgs() As Object) As T()
        If Not DispatchSorter Is Nothing Then System.Array.Sort(DelegateInfo.Actions, DispatchSorter)
        Dim args As Argument() = DelegateInfo.GetArgs(callArgs)
        Dim ret As T() = New T() {}
        For Each item As IAspectFunction In DelegateInfo.Functions
            OnBeforeDispatch(item, DelegateInfo, args)
            ret = item.GetValues(Of T)(args)
            OnAfterDispatch(item, DelegateInfo, args, ret)
        Next
        Return ret
    End Function

#End Region

End Module